Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/msword1a/wbrwordd.frm

Visual Basic Form | 1999-08-27 | 23.5 KB | 694 lines

VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "SHDOCVW.DLL"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmWbrWordDemo
   Caption         =   "Word Demo"
   ClientHeight    =   3510
   ClientLeft      =   60
   ClientTop       =   630
   ClientWidth     =   5280
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   3510
   ScaleWidth      =   5280
   WindowState     =   2  'Maximized
   Begin MSComctlLib.StatusBar sta
      Align           =   2  'Align Bottom
      Height          =   315
      Left            =   0
      TabIndex        =   1
      Top             =   3195
      Width           =   5280
      _ExtentX        =   9313
      _ExtentY        =   556
      Style           =   1
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
         NumPanels       =   1
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
         EndProperty
      EndProperty
   End
   Begin SHDocVwCtl.WebBrowser wbr
      Height          =   2475
      Left            =   360
      TabIndex        =   0
      Top             =   360
      Width           =   4515
      ExtentX         =   7964
      ExtentY         =   4366
      ViewMode        =   1
      Offline         =   0
      Silent          =   0
      RegisterAsBrowser=   0
      RegisterAsDropTarget=   0
      AutoArrange     =   -1  'True
      NoClientEdge    =   0   'False
      AlignLeft       =   0   'False
      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
      Location        =   ""
   End
   Begin VB.Menu mnuFileMenu
      Caption         =   "&File"
      Begin VB.Menu mnuFile
         Caption         =   "&Open..."
         Index           =   0
      End
      Begin VB.Menu mnuFile
         Caption         =   "&Close"
         Index           =   1
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuFile
         Caption         =   "&Save"
         Index           =   3
      End
      Begin VB.Menu mnuFile
         Caption         =   "Save &As..."
         Index           =   4
      End
      Begin VB.Menu mnuFile
         Caption         =   "Save as &HTML..."
         Index           =   5
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   6
      End
      Begin VB.Menu mnuFile
         Caption         =   "Page Set&up..."
         Index           =   7
      End
      Begin VB.Menu mnuFile
         Caption         =   "&Print..."
         Index           =   8
         Shortcut        =   ^P
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   9
      End
      Begin VB.Menu mnuFile
         Caption         =   "Properties"
         Index           =   10
         Begin VB.Menu mnuFileProps
            Caption         =   "Summary Info"
            Index           =   0
         End
         Begin VB.Menu mnuFileProps
            Caption         =   "Word Count"
            Index           =   1
         End
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   11
      End
      Begin VB.Menu mnuFile
         Caption         =   "Close &Window"
         Index           =   12
      End
      Begin VB.Menu mnuFile
         Caption         =   "&Format HTML"
         Index           =   13
      End
   End
   Begin VB.Menu mnuViewMenu
      Caption         =   "&View"
      Enabled         =   0   'False
      Begin VB.Menu mnuView
         Caption         =   "Normal View"
         Index           =   0
      End
      Begin VB.Menu mnuView
         Caption         =   "Page Layout"
         Index           =   1
      End
      Begin VB.Menu mnuView
         Caption         =   "-"
         Index           =   2
      End
      Begin VB.Menu mnuView
         Caption         =   "Horizontal Scroll"
         Index           =   3
      End
      Begin VB.Menu mnuView
         Caption         =   "Ruler"
         Index           =   4
      End
      Begin VB.Menu mnuView
         Caption         =   "Toolbars"
         Index           =   5
         Begin VB.Menu mnuViewToolbar
            Caption         =   "Standard"
            Index           =   0
         End
         Begin VB.Menu mnuViewToolbar
            Caption         =   "Formatting"
            Index           =   1
         End
         Begin VB.Menu mnuViewToolbar
            Caption         =   "Drawing"
            Index           =   2
         End
         Begin VB.Menu mnuViewToolbar
            Caption         =   "Reviewing"
            Index           =   3
         End
      End
   End
   Begin VB.Menu mnuToolsMenu
      Caption         =   "&Tools"
      Enabled         =   0   'False
      Begin VB.Menu mnuTools
         Caption         =   "&Spelling"
         Index           =   0
      End
      Begin VB.Menu mnuTools
         Caption         =   "&Thesaurus..."
         Index           =   1
      End
      Begin VB.Menu mnuTools
         Caption         =   "&Options"
         Index           =   2
         Begin VB.Menu mnuOpt
            Caption         =   "Show All"
            Index           =   0
         End
         Begin VB.Menu mnuOpt
            Caption         =   "Status Bar"
            Checked         =   -1  'True
            Index           =   1
         End
      End
   End
   Begin VB.Menu mnuDemoMenu
      Caption         =   "&Demo"
      Enabled         =   0   'False
      Begin VB.Menu mnuDemo
         Caption         =   "&Title"
         Index           =   0
      End
      Begin VB.Menu mnuDemo
         Caption         =   "&SubTitle"
         Index           =   1
      End
      Begin VB.Menu mnuDemo
         Caption         =   "&Data"
         Index           =   2
      End
      Begin VB.Menu mnuDemo
         Caption         =   "&Notes"
         Index           =   3
      End
      Begin VB.Menu mnuDemo
         Caption         =   "-"
         Index           =   4
      End
      Begin VB.Menu mnuDemo
         Caption         =   "&All"
         Index           =   5
      End
   End
Attribute VB_Name = "frmWbrWordDemo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' WbrWordDemo.frm v1.00 (Vb6) Apr 1999  Contact [e-mail]
' Adapted from WbrWord.frm to demonstrate manipulation of
'   MS Word Document contained by a WebBrowser Control.
' Requires provided sample files (see constants DEMO_DOC and DEMO_DAT)
'=================================================================================
' Module-level Variables
Private MARGINx2 As Long
Private mTopUsedArea As Long    ' varies with ToolBar/Captions visibility
Private mBotUsedArea As Long    ' varies with StatusBar visibility
Private mVertUsedArea As Long   ' = mTopUsedArea + mBotUsedArea
Private mDoc As Word.Document   ' Word Document contained by WebBrowser Control
Private mDocURL As String       ' URL of Word Document contained by WebBrowser Control
Private mFilePath As String     '<== Demo
' Module-level Constants
Private Const MARGIN = 0        ' set as required (Twips)
Private Const DEMO_DOC = "WbrWordDemo.doc"  ' template with Bookmarks defined
Private Const DEMO_DAT = "WbrWordDemo.txt"  ' for Word InsertFile Method
Private Const TITLE_BODY = "<BODY SCROLL=NO>" _
            & "MS Word<BR>Document<BR>Container" _
            & "<DIV ID=idDIV>(Hint: try File/Format HTML/or open)</DIV>" _
            & "</BODY>"
Private Const TITLE_PAGE = "about:" & TITLE_BODY
' Browser navigation constants
Private Const navNoHistory = 2
Private Const navNoReadFromCache = 4
Private Const navNoWriteToCache = 8
Private Const mNavFlags = navNoHistory Or navNoReadFromCache Or navNoWriteToCache
' File Menu constants
Private Const FILE_OPEN = 0
Private Const FILE_CLOSE = 1
Private Const FILE_SAVE = 3
Private Const FILE_SAVEAS = 4
Private Const FILE_SAVEASHTML = 5
Private Const FILE_PAGESETUP = 7
Private Const FILE_PRINT = 8
Private Const FILE_PROPS = 10
Private Const FILE_CLOSEWIN = 12
Private Const FILE_FORMAT = 13  '<== Demo
' Properties Menu constants
Private Const PROP_SUMMARY = 0
Private Const PROP_WORDCOUNT = 1
' View Menu constants
Private Const VIEW_NORMAL = 0
Private Const VIEW_PAGE = 1
Private Const VIEW_HSCROLL = 3
Private Const VIEW_RULER = 4
' Tool Menu constants
Private Const TOOLS_SPELL = 0
Private Const TOOLS_THESAURUS = 1
Private Const TOOLS_OPTIONS = 2
' Option Menu constants
Private Const OPT_SHOWALL = 0
Private Const OPT_STATUSBAR = 1
' Demo Menu Constants
Private Const DEMO_TITLE = 0
Private Const DEMO_SUBTITLE = 1
Private Const DEMO_DATA = 2
Private Const DEMO_NOTES = 3
Private Const DEMO_ALL = 5
Private Sub Form_Load()
    MARGINx2 = MARGIN * 2
    mTopUsedArea = MARGIN   ' + VB toolbar height, if present
    mBotUsedArea = sta.Height
    mVertUsedArea = mTopUsedArea + mBotUsedArea
    mFilePath = App.Path & "\"   '<== Demo
    wbr.Navigate TITLE_PAGE, mNavFlags
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    '<== Demo
    If UnloadMode <> vbFormCode Then
        If mnuViewMenu Then ' Word doc is currently in browser
            Cancel = True
            MsgBox "Please use the File Menu to close", _
                    vbExclamation, _
                    "Closing Demo..."
        End If
    End If
    '<== Demo
End Sub
Private Sub Form_Resize()
    On Error Resume Next
    wbr.Move MARGIN, mTopUsedArea, Me.ScaleWidth - MARGINx2, Me.ScaleHeight - mVertUsedArea
End Sub
Private Sub mnuFileMenu_Click()
    Dim IsWordDoc As Boolean
    Dim IsSaved As Boolean
    IsWordDoc = Not (mDoc Is Nothing)
    If IsWordDoc Then
        IsSaved = mDoc.Saved
    End If
    mnuFile(FILE_CLOSE) = IsWordDoc
    mnuFile(FILE_SAVE) = False  '<== Demo
    mnuFile(FILE_SAVEAS) = IsWordDoc
    mnuFile(FILE_SAVEASHTML) = IsWordDoc
    mnuFile(FILE_PAGESETUP) = IsWordDoc
    mnuFile(FILE_PRINT) = IsWordDoc
    mnuFile(FILE_PROPS) = IsWordDoc
    mnuFile(FILE_CLOSEWIN) = IsSaved Or Not IsWordDoc
End Sub
Private Sub mnuFile_Click(Index As Integer)
    On Error Resume Next
    Select Case Index
        Case FILE_OPEN
            wbr.Navigate mFilePath & DEMO_DOC, mNavFlags  '<== Demo

        Case FILE_CLOSE
            mDoc.Saved = True   '<== Demo
            wbr.Navigate TITLE_PAGE, mNavFlags  ' removes Word document but
                                                ' DOES NOT close Word instance
        Case FILE_SAVE
            wbr.ExecWB _
                cmdID:=OLECMDID_SAVE, _
                cmdexecopt:=OLECMDEXECOPT_PROMPTUSER

        Case FILE_SAVEAS
            wbr.ExecWB _
                cmdID:=OLECMDID_SAVEAS, _
                cmdexecopt:=OLECMDEXECOPT_PROMPTUSER

        Case FILE_SAVEASHTML
            FileSaveAsHTML

        Case FILE_PAGESETUP
            wbr.ExecWB _
                cmdID:=OLECMDID_PAGESETUP, _
                cmdexecopt:=OLECMDEXECOPT_PROMPTUSER

        Case FILE_PRINT
            wbr.ExecWB _
                cmdID:=OLECMDID_PRINT, _
                cmdexecopt:=OLECMDEXECOPT_PROMPTUSER

        Case FILE_CLOSEWIN
            Unload Me

        Case FILE_FORMAT    '<== Demo
            FormatTitlePage
            mnuFile(FILE_FORMAT).Visible = False

    End Select
End Sub
Private Sub mnuFileProps_Click(Index As Integer)
' See VbaWrd8.HLP for distinction between "Show" and "Display" methods
    On Error Resume Next
    Select Case Index
        Case PROP_SUMMARY  ' Word Document Summary Info
            mDoc.Application.Dialogs(wdDialogFileSummaryInfo).Show

        Case PROP_WORDCOUNT  ' Word Document Word Count (display only)
            mDoc.Application.Dialogs(wdDialogToolsWordCount).Display

    End Select

End Sub
Private Sub mnuViewMenu_Click()
    On Error Resume Next
    Dim mnu As Menu
    With mDoc
        With .ActiveWindow
            mnuView(VIEW_NORMAL).Checked = (.View.Type = wdNormalView)
            mnuView(VIEW_PAGE).Checked = (.View.Type = wdPageView)
            mnuView(VIEW_HSCROLL).Checked = .DisplayHorizontalScrollBar
            mnuView(VIEW_RULER).Checked = .DisplayRulers
        End With

        For Each mnu In mnuViewToolbar  ' Assumes Menu captions match Toolbar names
            mnu.Checked = .CommandBars(mnu.Caption).Visible
        Next

    End With
End Sub
Private Sub mnuView_Click(Index As Integer)
    On Error Resume Next
    With mDoc.ActiveWindow
        Select Case Index

            Case VIEW_NORMAL
                .View.Type = wdNormalView

            Case VIEW_PAGE
                .View.Type = wdPageView

            Case VIEW_HSCROLL
                .DisplayHorizontalScrollBar = Not .DisplayHorizontalScrollBar

            Case VIEW_RULER
               .DisplayRulers = Not .DisplayRulers

        End Select
    End With
End Sub
Private Sub mnuViewToolbar_Click(Index As Integer)
    On Error Resume Next
    Dim msoBarPos As Office.MsoBarPosition
    Dim strToolbarName As String
    strToolbarName = mnuViewToolbar(Index).Caption
    With mDoc.CommandBars(strToolbarName)
        .Enabled = True ' ToolBar must be Enabled before it can be made Visible
        .Visible = Not .Visible
        mnuViewToolbar(Index).Checked = .Visible

        If .Visible Then

            Select Case strToolbarName

                Case "Drawing"
                    msoBarPos = msoBarBottom

                Case "Reviewing"
                    msoBarPos = msoBarRight

                Case Else
                    msoBarPos = msoBarTop
            End Select

            .Position = msoBarPos
        End If

    End With
End Sub
Private Sub mnuToolsMenu_Click()
    On Error Resume Next
    With mDoc
        mnuTools(TOOLS_SPELL) = Not .SpellingChecked

        With .Application.Selection ' restrict to one word only
            mnuTools(TOOLS_THESAURUS) = (.Type = wdSelectionNormal) _
                                    And (.Words.Count = 1)
        End With

    End With
End Sub
Private Sub mnuTools_Click(Index As Integer)
    On Error Resume Next
    Select Case Index
        Case TOOLS_SPELL
            mDoc.CheckSpelling

        Case TOOLS_THESAURUS
            mDoc.Application.Selection.Range.CheckSynonyms

        Case TOOLS_OPTIONS
            mnuOpt(OPT_SHOWALL).Checked = mDoc.ActiveWindow.View.ShowAll
            mnuOpt(OPT_STATUSBAR).Checked = sta.Visible

    End Select
End Sub
Private Sub mnuOpt_Click(Index As Integer)
    On Error Resume Next
    Dim blnChecked As Boolean
    With mnuOpt(Index)
        .Checked = Not .Checked
        blnChecked = .Checked
    End With
    Select Case Index
        Case OPT_SHOWALL
            mDoc.ActiveWindow.View.ShowAll = blnChecked

        Case OPT_STATUSBAR
            sta.Visible = blnChecked
            SetBotUsedArea

    End Select
End Sub
Private Sub wbr_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    On Error GoTo DocumentComplete_Error
    mnuDemoMenu = False '<== Demo
    If pDisp Is wbr.Object Then
        mnuViewMenu = TypeOf wbr.Document Is Word.Document
        mnuToolsMenu = mnuViewMenu

        If mnuViewMenu Then
            Set mDoc = wbr.Document
            mDocURL = URL
            sta.SimpleText = "Done"
            '<== Demo
            mnuDemoMenu = InStr(1, URL, DEMO_DOC, vbTextCompare)
            mnuDemo(DEMO_TITLE) = mnuDemoMenu
            mnuDemo(DEMO_SUBTITLE) = mnuDemoMenu
            mnuDemo(DEMO_DATA) = mnuDemoMenu
            mnuDemo(DEMO_NOTES) = mnuDemoMenu
            mnuDemo(DEMO_ALL) = mnuDemoMenu
            '<== Demo
        Else
            Set mDoc = Nothing
            mDocURL = vbNullString
        End If

        mnuFile(FILE_FORMAT).Visible = InStr(1, URL, "about:", vbTextCompare)   '<== Demo
   End If
DocumentComplete_Exit:
    Exit Sub
DocumentComplete_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".DocumentComplete"
    Resume DocumentComplete_Exit
End Sub
Private Sub wbr_StatusTextChange(ByVal Text As String)
    sta.SimpleText = Text
End Sub
Private Sub FileSaveAsHTML()
' This can also be done with the "SaveAs" option.
' Note that ConvHTML.SaveDocAsHTML could be used to convert a
' document to HTML withtout user intervention if parameters
' are provided by some other means.
    On Error GoTo FileSaveAsHTML_Error
    Dim FileName As String
    Dim lngPos As Long
    Dim strResult As String
    Dim strMsg As String
    Dim lngStyle As VbMsgBoxStyle
    lngPos = InStrRev(mDocURL, "\", , vbTextCompare)
    If lngPos Then
        FileName = Mid$(mDocURL, lngPos + 1)
        FileName = Split(FileName, ".")(0) & ".html"
        FileName = LCase$(FileName)
    End If
    strResult = FileDlgs.GetSaveAsFileName( _
                    FileName, _
                    App.Path, _
                    "HTML Document (*.htm;*.html):*.htm;*.html")

    If Len(strResult) Then
        FileName = ConvHTML.SaveDocAsHTML( _
                    Doc:=mDoc, _
                    NewFileName:=strResult)
        If Len(FileName) Then
            strMsg = mDocURL & vbNewLine & vbNewLine _
                    & vbTab & "saved in HTML format as" & vbNewLine & vbNewLine _
                    & FileName
            lngStyle = vbInformation
        Else
            strMsg = "ERROR: Save operation failed"
            lngStyle = vbExclamation
        End If
        MsgBox strMsg, lngStyle, "Save As HTML"
    End If
FileSaveAsHTML_Exit:
    Exit Sub
FileSaveAsHTML_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".FileSaveAsHTML"
    Resume FileSaveAsHTML_Exit
End Sub
Private Sub SetBotUsedArea()
    With sta
        .Refresh
        mBotUsedArea = IIf(.Visible, .Height + MARGIN, MARGIN)
    End With
    mVertUsedArea = mTopUsedArea + mBotUsedArea
    Form_Resize
End Sub
'<== Demo additions ==================================================
Private Sub mnuDemo_Click(Index As Integer)
'   Manipulates DEMO_DOC using pre-defined BookMarks
    On Error GoTo mnuDemo_Error
    Dim MenuCaption As String
    MenuCaption = "mnuDemo(" & Index & ") - " & mnuDemo(Index).Caption
    sta.SimpleText = MenuCaption
    Select Case Index
        Case DEMO_TITLE
            mDoc.Bookmarks("BMTitle").Range.InsertAfter ("This is the Title")

        Case DEMO_SUBTITLE
           mDoc.Bookmarks("BMSubTitle").Range.InsertAfter ("This is the Sub-title")

        Case DEMO_DATA
           InsertData DataFileName:=mFilePath & DEMO_DAT

        Case DEMO_NOTES
            With mDoc.Bookmarks("BMNotes").Range
                .InsertAfter _
                    Text:="Explanatory notes go here" & vbNewLine _
                        & "and can be as many lines as necessary." _
                        & vbNewLine & vbNewLine _
                        & "Or perhaps a Text Box could be defined for the user " _
                        & "to enter comments before printing."
            End With

         Case DEMO_ALL
            AutoSequence    ' = all of the above !!

    End Select
    mDoc.Application.Selection.GoTo what:=wdGoToBookmark, Name:="BMTop"
mnuDemo_Exit:
    mnuDemo(Index) = False
    mnuDemo(DEMO_ALL) = False
    sta.SimpleText = vbNullString
    Exit Sub
mnuDemo_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                    Me.Name & "." & MenuCaption
    Resume mnuDemo_Exit
End Sub
Private Sub InsertData(DataFileName As String)
' Inserts the contents of file DEMO_DAT
' and formats resultant text as a Word Table
    On Error GoTo InsertData_Error
    Dim rng As Word.Range
    With mDoc.Application.Selection  ' insert data after Bookmark
        .GoTo what:=wdGoToBookmark, Name:="BMData"
        .MoveDown
        Set rng = .Range    ' for repositoning after Insert
        .InsertFile FileName:=DataFileName
    End With
    rng.Select
    With mDoc.Application.Selection  ' format data as Table
        .MoveDown Unit:=wdLine, Count:=4, Extend:=wdExtend
        .ConvertToTable _
            Separator:=wdSeparateByTabs, _
            AutoFit:=False
        .Tables(1).AutoFormat _
            Format:=wdTableFormatColorful2, _
            AutoFit:=False
    End With
InsertData_Exit:
    Exit Sub
InsertData_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".InsertData"
    Resume InsertData_Exit
End Sub
Private Sub AutoSequence()
    On Error GoTo AutoSequence_Exit
    mnuDemoMenu = False
    mDoc.Application.ScreenUpdating = False
    mnuDemo_Click DEMO_TITLE
    mnuDemo_Click DEMO_SUBTITLE
    mnuDemo_Click DEMO_DATA
    mnuDemo_Click DEMO_NOTES
AutoSequence_Exit:
    mDoc.Application.ScreenUpdating = True
End Sub
Private Sub FormatTitlePage()   ' Late-binding
' This little bit of nonsense demonstrates the manipulation of
' an HTML Document Object contained by a WebBrowser Control.
' Recommended method is to set a "Project/References" to
'       "Microsoft HTML Object Library" (mshtml.dll)
' and use strictly-typed objects for early-binding.
' That also makes Tools/Options/Editor/Auto List Members available in the IDE.
    On Error GoTo FormatTitlePage_Error
    Const strHR = "<HR style=color:cyan;width:300>"
    With wbr.Document.body
        With .Style
            .backgroundcolor = "#689CD0"
            .Color = "white"
            .fontfamily = "Comic Sans MS"
            .FontSize = "48pt"
            .TextAlign = "center"
        End With

        With .All.idDIV
            .innerHTML = "Automation<BR>Demonstration"  ' multiple-statements
            .insertAdjacentHTML "BeforeBegin", strHR    ' to demonstrate more
            .insertAdjacentHTML "AfterEnd", strHR       ' avaliable functions.

            With .Style
                .Color = "yellow"
                .fontfamily = "serif"
                .FontSize = "32pt"
            End With

        End With

    End With
FormatTitlePage_Exit:
    Exit Sub
FormatTitlePage_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, _
                Me.Name & ".FormatTitlePage"
    Resume FormatTitlePage_Exit
End Sub